Programmers Heaven 2/Programmers Heaven 2.iso/files/windows/ocx/midipk.exe/SYSEX.FRM

Visual Basic Form | 1996-06-27 | 21.7 KB | 605 lines

VERSION 4.00
Begin VB.Form frmMain
   BorderStyle     =   1  'Fixed Single
   Caption         =   "MIDI CoolTools - System Exclusive Example"
   ClientHeight    =   3750
   ClientLeft      =   3540
   ClientTop       =   3630
   ClientWidth     =   9255
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   0
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   Height          =   4440
   Icon            =   "SYSEX.frx":0000
   Left            =   3480
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   3750
   ScaleWidth      =   9255
   Top             =   3000
   Width           =   9375
   Begin VB.Frame FrameSysexList
      Caption         =   "Sysex Bank List"
      Height          =   1755
      Left            =   30
      TabIndex        =   11
      Top             =   30
      Width           =   4185
      Begin VB.ListBox ListSysex
         Appearance      =   0  'Flat
         Height          =   1395
         Left            =   120
         MultiSelect     =   2  'Extended
         TabIndex        =   12
         Top             =   270
         Width           =   3825
      End
   End
   Begin VB.Frame FrameSysexEdit
      Caption         =   "Edit MIDI System Exclusive Message"
      Height          =   1365
      Left            =   30
      TabIndex        =   9
      Top             =   1860
      Width           =   9135
      Begin VB.TextBox TextSysex
         Appearance      =   0  'Flat
         BeginProperty Font
            name            =   "MS Sans Serif"
            charset         =   0
            weight          =   400
            size            =   8.25
            underline       =   0   'False
            italic          =   0   'False
            strikethrough   =   0   'False
         EndProperty
         Height          =   1005
         Left            =   90
         MultiLine       =   -1  'True
         ScrollBars      =   1  'Horizontal
         TabIndex        =   10
         Text            =   "SYSEX.frx":030A
         Top             =   270
         Width           =   8955
      End
   End
   Begin VB.Frame Frame5
      Caption         =   "MIDI Filter"
      Height          =   1755
      Left            =   7410
      TabIndex        =   6
      Top             =   30
      Width           =   1755
      Begin VB.CheckBox CheckMIDIFilter1
         Caption         =   "Active Sensing"
         BeginProperty Font
            name            =   "MS Sans Serif"
            charset         =   0
            weight          =   400
            size            =   8.25
            underline       =   0   'False
            italic          =   0   'False
            strikethrough   =   0   'False
         EndProperty
         Height          =   225
         Left            =   150
         TabIndex        =   1
         Top             =   1200
         Value           =   1  'Checked
         Width           =   1395
      End
      Begin VB.CheckBox CheckMIDIFilter2
         Caption         =   "Undefined F9"
         BeginProperty Font
            name            =   "MS Sans Serif"
            charset         =   0
            weight          =   400
            size            =   8.25
            underline       =   0   'False
            italic          =   0   'False
            strikethrough   =   0   'False
         EndProperty
         Height          =   225
         Left            =   150
         TabIndex        =   8
         Top             =   840
         Value           =   1  'Checked
         Width           =   1335
      End
      Begin VB.CheckBox CheckMIDIFilter3
         Caption         =   "MIDI Time Clock"
         BeginProperty Font
            name            =   "MS Sans Serif"
            charset         =   0
            weight          =   400
            size            =   8.25
            underline       =   0   'False
            italic          =   0   'False
            strikethrough   =   0   'False
         EndProperty
         Height          =   405
         Left            =   150
         TabIndex        =   7
         Top             =   330
         Value           =   1  'Checked
         Width           =   1455
      End
   End
   Begin VB.Frame Frame4
      Caption         =   "Receive [In] System Exclusive"
      Height          =   705
      Left            =   4290
      TabIndex        =   4
      Top             =   30
      Width           =   3075
      Begin VB.CommandButton CmdReceiveSysex
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         Caption         =   "Receive Sysex Message"
         BeginProperty Font
            name            =   "MS Sans Serif"
            charset         =   0
            weight          =   400
            size            =   8.25
            underline       =   0   'False
            italic          =   0   'False
            strikethrough   =   0   'False
         EndProperty
         Height          =   315
         Left            =   60
         TabIndex        =   5
         Top             =   270
         Width           =   2925
      End
   End
   Begin VB.Frame Frame3
      Caption         =   "Send [Out] System Exclusive"
      Height          =   735
      Left            =   4290
      TabIndex        =   2
      Top             =   750
      Width           =   3075
      Begin VB.CommandButton CmdSendSysex
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         Caption         =   "Send Selected Sysex Message"
         BeginProperty Font
            name            =   "MS Sans Serif"
            charset         =   0
            weight          =   400
            size            =   8.25
            underline       =   0   'False
            italic          =   0   'False
            strikethrough   =   0   'False
         EndProperty
         Height          =   315
         Left            =   60
         TabIndex        =   3
         Top             =   300
         Width           =   2925
      End
   End
   Begin MidiioLib.MIDIOutput MIDIOutput1
      Left            =   600
      Top             =   3240
      _Version        =   65537
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      DeviceID        =   0
      VolumeLeft      =   -1
      VolumeRight     =   -1
   End
   Begin MidiioLib.MIDIInput MIDIInput1
      Left            =   120
      Top             =   3240
      _Version        =   65537
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      MessageEventEnable=   -1  'True
      MaxSysexSize    =   32000
   End
   Begin MSComDlg.CommonDialog CMDialog1
      Left            =   1080
      Top             =   3240
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      DialogTitle     =   "System Exclusive Binary Files"
      Filter          =   "(*.syx) Sysex |*.syx|"
   End
   Begin VB.Label LblInQueue
      Appearance      =   0  'Flat
      BackColor       =   &H00000000&
      Caption         =   " MIDI Sysex Status"
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   400
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H0000FF00&
      Height          =   225
      Left            =   4290
      TabIndex        =   0
      Top             =   1530
      Width           =   3075
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileLoadBank
         Caption         =   "&Load Bank"
      End
      Begin VB.Menu MnuSaveBankAs
         Caption         =   "Save Bank &As..."
         Shortcut        =   ^A
      End
      Begin VB.Menu mnuFileSep1
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuMidi
      Caption         =   "&MIDI"
      Begin VB.Menu mnuMidiSetup
         Caption         =   "&Setup"
      End
      Begin VB.Menu mnuMidiThru
         Caption         =   "&Thru"
         Checked         =   -1  'True
      End
   End
   Begin VB.Menu mnuHelp
      Caption         =   "&Help"
      Begin VB.Menu mnuHelpAbout
         Caption         =   "&About"
      End
   End
Attribute VB_Name = "frmMain"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim DisplayBufferString(200) As String
Dim UserMessage As String
Private Sub CheckMIDIFilter1_Click()
    If CheckMIDIFilter1.Value = 0 Then
        MIDIInput1.Filter(FILTER_F9) = False
    Else
        MIDIInput1.Filter(FILTER_F9) = True
    End If
End Sub
Private Sub CheckMIDIFilter2_Click()
    If CheckMIDIFilter2.Value = 0 Then
        MIDIInput1.Filter(FILTER_ACTIVE_SENSE) = False
    Else
        MIDIInput1.Filter(FILTER_ACTIVE_SENSE) = True
    End If
End Sub
Private Sub CheckMIDIFilter3_Click()
    If CheckMIDIFilter3.Value = 0 Then
        MIDIInput1.Filter(FILTER_CLOCK) = False
    Else
        MIDIInput1.Filter(FILTER_CLOCK) = True
    End If
End Sub
Private Sub CmdReceiveSysex_Click()
    MIDIInput1.Action = MIDIIN_START
    ' MIDI Data is being received
    LblInQueue.Caption = " Waiting for data..."
End Sub
Private Sub CmdReceiveSysex_LostFocus()
    'UserMessage string is used when data is being received.
    'It is used only to show that progress is happening
    UserMessage = " Receiving data..."
End Sub
Private Sub CmdSendSysex_Click()
    Dim I As Integer
    Dim n As Integer
    Dim SysexMessage As String
    Dim StringPosition As Integer
    '**NOTE**
    '
    'If all you want to do is send simple sysex messages, you can format
    'them as simple as this example.  (A Sysex message is sent which resets
    'the Roland SoundCanvas SC-88 to General MIDI mode)
    '
    'Midioutput1.message = &HF0
    'Midioutput1.Buffer = Chr$(&HF0) + Chr$(&H7E) + Chr$(&H7F) + Chr$(9) + Chr$(1) + Chr$(&HF7)
    'Midioutput1.Action = MIDIOUT_SEND
    '
    'In this example the first and last bytes (&HF0 and &HF7) signal the
    'beginning and end of a Sysex message.  The middle bytes are the Sysex
    'message contents.
    ' MIDI Data is being sent
    LblInQueue.Caption = " Sending data..."
    LblInQueue.Refresh
    'Look through ListSysex to see if you have selected some sysex
    'messages to send
    For I = 0 To ListSysex.ListCount - 1
        'When we first received the sysex message we reformated
        'it to make it easier to edit.  Now since we're going to send it,
        'we've got to get it back in its original format
        If ListSysex.Selected(I) = True Then
            SysexMessage = ""
            ListSysex.ListIndex = I
            '
            ' Must tell MIDI CoolTools that this is a sysex message
            MIDIOutput1.Message = &HF0

            'Start formating complete sysex message
            SysexMessage = Chr$("&H" + Left(DisplayBufferString(I), 2))

            'Starting position of InStr search
            n = 3
            'We're going into this loop until we've reformated the complete
            'sysex message
            Do While Len(DisplayBufferString(I)) > n
                '
                'Since we've got a bunch of spaces " " that we've got
                'to find in our reformating, we're going to use the
                'InStr function to help us find them.  Look in the VB
                'Help file if you don't understand InStr!
                StringPosition = InStr(n, DisplayBufferString(I), " ")
                '
                'If 0 then we'll not put in the &H
                If Trim(Mid(DisplayBufferString(I), StringPosition + 1, 2)) = "0" Then
                    SysexMessage = SysexMessage & Chr$(Trim(Mid(DisplayBufferString(I), StringPosition + 1, 2)))
                Else
                    'If not 0 but just null, then we do nothing
                    If Trim(Mid(DisplayBufferString(I), StringPosition + 1, 2)) = "" Then
                        'null
                    Else
                        SysexMessage = SysexMessage & Chr$("&H" & Trim(Mid(DisplayBufferString(I), StringPosition + 1, 2)))
                    End If
                End If
                n = StringPosition + 2
            Loop
            'Complete sysex message is all reformated and now ready
            'to be queued
            MIDIOutput1.Buffer = SysexMessage
            MIDIOutput1.Action = MIDIOUT_QUEUE
        End If
    Next I
    MIDIOutput1.Action = MIDIOUT_START
End Sub
Private Sub Form_Load()
    Dim I As Integer
    'UserMessage string is used when data is being received.
    'It is used only to show that progress is happening
    UserMessage = " Receiving data..."
    ' Center the form on the screen
    Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
End Sub
Private Sub Form_Unload(Cancel As Integer)
    ' Stop the MIDI In
    If (MIDIInput1.State <> 0) And (MIDIInput1.State <> 1) Then
        MIDIInput1.Action = MIDIIN_STOP
        End If
    ' Close MIDI In
    If (MIDIInput1.State <> 0) Then
        MIDIInput1.Action = MIDIIN_CLOSE
        End If
    ' Close MIDI Out
    MIDIOutput1.Action = MIDIOUT_CLOSE
    End
End Sub
Private Sub ListSysex_Click()
    'Display the sysex message that is stored in DisplayBufferString
    TextSysex.Text = DisplayBufferString(ListSysex.ListIndex)
End Sub
Private Sub MIDIInput1_Error(ErrorCode As Integer, ErrorMessage As String)
    '
    ' Midi input error, display message
    '
   If (ErrorCode <> 0) And (ErrorCode <> 8) Then
      MsgBox ErrorMessage
      End If
End Sub
Private Sub MIDIInput1_Message()
    Dim n As Integer
    Dim SysexListCount As Integer
    SysexListCount = ListSysex.ListCount
    '
    ' The MIDIInput1.SysexMaxSize property is set to 5000 bytes in this
    ' example.  For larger system exclusive messages, increase this
    ' property. If you are not going to receive system exclusive
    ' message, set the SysexMaxSize property to 0.
    '
    '
    'This do while loop allows you to take all the messages that are
    'waiting in the message queue.
    Do While MIDIInput1.MessageCount > 0 And Len(MIDIInput1.Buffer) > 0
        'Show the users that data is coming in
        UserMessage = UserMessage + "...."
        LblInQueue.Caption = UserMessage
        LblInQueue.Refresh

        '
        'Add each Message to the List box so that the users can click
        'through each message.  We'll set this up to allow the users
        'to view and edit the complete sysex message
        ListSysex.AddItem "Message " & Str(SysexListCount) & " Length=" & Str(Len(MIDIInput1.Buffer))
        'A complete sysex message has been received into the
        'MIDIInput.Buffer
        '
        'Now we'll put the first data byte of sysex message into
        'the DisplayBufferString.
        DisplayBufferString(SysexListCount) = Hex(Asc(Left(MIDIInput1.Buffer, 1)))
        'Now we're going to go through the remaining portion of the
        'sysex message and get it ready to display.  We'll then be able
        'to view and edit the complete sysex message.
        For n = 2 To Len(MIDIInput1.Buffer)
            DisplayBufferString(SysexListCount) = DisplayBufferString(SysexListCount) & " " & Hex(Asc(Mid(MIDIInput1.Buffer, n, 1)))
        Next n
        '
        'DisplayBufferString now contains the sysex message in a viewable
        'format
        '
        'Remove the MIDI data from the MIDI IN queue
        '
        MIDIInput1.Action = MIDIIN_REMOVE
    Loop
    ' IF the buffer is > 0 then we've received some sysex data
    If Len(DisplayBufferString(SysexListCount)) > 0 Then
        LblInQueue.Caption = " Sysex Data Received!"
    ElseIf mnuMidiThru.Checked = True Then
        'If MIDI Thru is checked in the menu, send non-sysex data out
        MIDIOutput1.Message = MIDIInput1.Message
        MIDIOutput1.Data1 = MIDIInput1.Data1
        MIDIOutput1.Data2 = MIDIInput1.Data2
        MIDIInput1.Action = MIDIIN_REMOVE
        MIDIOutput1.Action = MIDIOUT_START
        MIDIOutput1.Action = MIDIOUT_SEND
        MIDIOutput1.Action = MIDIOUT_STOP
    End If
End Sub
Private Sub MIDIOutOpen()
End Sub
Private Sub MIDIOutput1_Error(ErrorCode As Integer, ErrorMessage As String)
    '
    ' Midi output error, display message
    '
   If (ErrorCode <> 0) And (ErrorCode <> 8) Then
      MsgBox ErrorMessage
      End If
End Sub
Private Sub MIDIOutput1_QueueEmpty()
    '
    'Once queue becomes empty, get ready to record again
    '
    MIDIOutput1.Action = MIDIOUT_STOP
    ' MIDI Data is being received
    LblInQueue.Caption = " Data Sent!"
End Sub
Private Sub mnuFileExit_Click()
    ' Stop the MIDI In
    MIDIInput1.Action = MIDIIN_STOP
    ' Close MIDI In
    MIDIInput1.Action = MIDIIN_CLOSE
    ' Close MIDI Out
    MIDIOutput1.Action = MIDIOUT_CLOSE
    End
End Sub
Private Sub mnuFileLoadBank_Click()
    Dim SysexBytes As String
    Dim SysexListCount As Integer
    Dim X As Integer
    SysexListCount = ListSysex.ListCount
    On Error Resume Next
    CMDialog1.DialogTitle = "Load System Exclusive File"
    CMDialog1.Flags = &H1000&
    CMDialog1.Action = 1
    If (Err) Then
        Exit Sub
    End If
    Open CMDialog1.filename For Binary As #1
    Do While EOF(1) <> True
        SysexBytes = " "
        Get #1, , SysexBytes
        DisplayBufferString(SysexListCount) = LTrim(DisplayBufferString(SysexListCount)) & " " & Hex(Asc(SysexBytes))
    Loop
    Close #1
    DisplayBufferString(SysexListCount) = Left(DisplayBufferString(SysexListCount), (Len(DisplayBufferString(SysexListCount)) - 2))
    ListSysex.AddItem CMDialog1.filename & " Len =" & Str(Len(DisplayBufferString(SysexListCount)))
    'unselect all
    For X = 0 To ListSysex.ListCount - 1
        ListSysex.Selected(X) = False
    Next
    'Highlight the loaded file
    ListSysex.Selected(ListSysex.ListCount - 1) = True
End Sub
Private Sub mnuMidiSetup_Click()
    MIDISetupForm.Show MODAL
End Sub
Private Sub mnuMidiThru_Click()
    'Switch check mark on and off
    If mnuMidiThru.Checked = True Then
        mnuMidiThru.Checked = False
    Else
        mnuMidiThru.Checked = True
    End If
End Sub
Private Sub MnuSaveBankAs_Click()
    Dim I As Integer
    Dim n As Integer
    Dim SysexMessage As String
    Dim StringPosition As Integer
    ' MIDI Data is being sent
    LblInQueue.Caption = " Saving data..."
    LblInQueue.Refresh
    On Error Resume Next
    CMDialog1.DialogTitle = "Save Selected Sysex Message"
    CMDialog1.Flags = &H1000&
    CMDialog1.Action = 2
    If (Err) Then
        Exit Sub
    End If
    Open CMDialog1.filename For Binary As #1
    SysexMessage = ""
    'Look through ListSysex to see if you have selected some sysex
    'messages to send
    For I = 0 To ListSysex.ListCount - 1
        'When we first received the sysex message we reformated
        'it to make it easier to edit.  Now since we're going to send it,
        'we've got to get it back in its original format
        If ListSysex.Selected(I) = True Then

            ListSysex.ListIndex = I
            '

            'Start formating complete sysex message
            SysexMessage = Chr$("&H" + Left(DisplayBufferString(I), 2))
            'Write begining F0 sysex byte to file
            Put #1, , SysexMessage

            'Starting position of InStr search
            n = 3
            'We're going into this loop until we've reformated the complete
            'sysex message
            Do While Len(DisplayBufferString(I)) > n
                '
                'Since we've got a bunch of spaces " " that we've got
                'to find in our reformating, we're going to use the
                'InStr function to help us find them.  Look in the VB
                'Help file if you don't understand InStr!
                StringPosition = InStr(n, DisplayBufferString(I), " ")
                '
                'If 0 then we'll not put in the &H
                If Trim(Mid(DisplayBufferString(I), StringPosition + 1, 2)) = "0" Then
                    SysexMessage = Chr$(Trim(Mid(DisplayBufferString(I), StringPosition + 1, 2)))
                Else
                    'If not 0 but just null, then we do nothing
                    If Trim(Mid(DisplayBufferString(I), StringPosition + 1, 2)) = "" Then
                        'null
                    Else
                        SysexMessage = Chr$("&H" & Trim(Mid(DisplayBufferString(I), StringPosition + 1, 2)))
                    End If
                End If
                'Write sysex data to file
                Put #1, , SysexMessage
                n = StringPosition + 2
            Loop
        End If
    Next I
    Close #1
End Sub
Private Sub TextSysex_Change()
    'You can edit the sysex message.  If you do make changes
    'we'll update DisplayBufferString with those changes
    DisplayBufferString(ListSysex.ListIndex) = TextSysex.Text
End Sub